home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops ƒ / Modules < prev    next >
Text File  |  1995-11-22  |  14KB  |  566 lines
  1. \ This file implements relocatable modules.  In installed applications,
  2. \ these become separate code segments.
  3.  
  4. true    value    CLEANMOD?
  5. false    value    RELEASED?
  6.     0    value    THIS_MOD
  7.     0    value    LAST_MOD
  8.     0    value    svDP
  9.     0    value    evSvDP
  10.     0    value    svLatest
  11.     0    value    evSvLatest
  12.     0    value    modstart
  13.  
  14.     string    $EXP
  15.     string    $CXT
  16.     string    $evCXT
  17.  
  18. \ variable    SAVE_CONTEXT    8 4 *  allot
  19.  
  20. : UNEVAL    \ Puts things back to normal after an EVAL"
  21.     evSvDP  0EXIT        \ Out if we're not compiling an eval"
  22.     evSvLatest -> latest
  23.     evSvDP -> DP  0 -> evSvDP
  24.     nil?: $evCxt  NIF  ptr: $evCxt  context  32 cmove  release: $evCxt  THEN
  25. ;
  26.  
  27. : UNMOD        \ Puts things back to normal after a module
  28.             \ or stand-alone code compilation or eval"
  29.     unEval
  30.     svDP  0EXIT        \ Out if we're not compiling a module/SA
  31.     svLatest -> latest
  32.     svDP -> DP  0 -> svDP  0 -> compMod
  33.     nil?: $cxt  NIF  ptr: $cxt  context  32  cmove  release: $cxt  THEN
  34.     false -> SAcomp?  ;
  35.  
  36. : >NXTEXP    \ ( n -- )
  37.     modstart -  pad !  pad 4  add: $exp  ;
  38.  
  39.  
  40. :class    MODULE    super{ object }
  41.  
  42. record
  43. {    handle    MODHDL
  44.     byte    EXEC_CNT        \ Must be at an even offset since we sometimes
  45.     bool    LOCKED?            \  do a combined access to exec_cnt and locked? !
  46.     byte    FLAGS
  47.     int        RES#
  48.     int        #IMP
  49.     dicaddr    LASTIMP
  50.     dicaddr    LOADPOINT
  51.     var        DicDateTime
  52.     int        RELOFFS
  53.     int        INSTALL?
  54. }
  55.  
  56. :m BASE:
  57.     nil?: modHdl  IF  0  EXIT  THEN
  58.     nptr: modHdl  ;m
  59.  
  60. :m HANDLE:    get: modHdl  ;m
  61.  
  62. :m .ID:        ^base obj>  .id  ;m
  63.  
  64. :m SETRELEASE:    \ ( addr -- )
  65.     modbase -  put: relOffs  ;m
  66.  
  67. :m SETRESID:    \ ( resID -- )
  68.     put: res#  ;m
  69.  
  70. :m INSTALL?:    get: install?  ;m
  71. :m SETINSTALL:    put: install?  ;m
  72.  
  73.  
  74. \ KLUDGE: and UNKLUDGE: may be used when we save a dic image, to mark
  75. \ a module as unloaded in the saved image without really unloading it.
  76.  
  77. :m KLUDGE:    \ ( -- modHdl flags exec+locked? )
  78.     get: modHdl  get: flags  addr: exec_cnt  w@  nilH  put: modHdl  ;m
  79.  
  80. :m UNKLUDGE:    \ ( modHdl flags exec+locked? -- )
  81.     addr: exec_cnt  w!  put: flags  put: modHdl  ;m
  82.  
  83. :m GETNAME:    \ ( -- addr len )
  84.     ^base  obj> >name n>count  ;m
  85.  
  86. :m EXTNAME:  { xaddr xlen \ len -- addr' len' }
  87.     getName: self  -> len   pad len cmove
  88.     xaddr  pad len +  xlen  cmove        \ Add extension
  89.     pad  len xlen +  ;m
  90.  
  91. :m BINNAME:    \ ( -- addr len )  Leaves name of binary file for module.
  92.     " .BIN" extName: self  ;m
  93.  
  94. :m TXTNAME:    \ ( -- addr len )  Leaves name of text file for module.
  95.     " .TXT" extName: self  ;m
  96.  
  97.  
  98. :m LOAD:  { \ rc -- }        \ Loads if not loaded already
  99.     nil?: modHdl  0EXIT
  100.     get: res#
  101.     IF    'type CODE  get: res#  getRes  dup 0= ?error 138
  102.         put: modHdl
  103.     ELSE
  104.         binName: self  name: fFcb  0 setVref: fFcb
  105.         openReadOnly: fFcb  ?error 138
  106.         ['] pause 4+ @  0 -> pause        \ Disable pause over read to avoid
  107.                                         \  possible reentrancy
  108.         size: fFcb  dup  new: modHdl
  109.         lock: modHdl                    \ Maybe we need this
  110.         ptr: modHdl  swap  read: fFcb  -> rc
  111.         ['] pause 4+ !                    \ Restore pause
  112.         unlock: modHdl                    \ Unlock before error check
  113.         close: fFcb  drop  rc ?error 141
  114.         base: self @  get: dicDateTime  u<
  115.         IF                                \ BIN file is old version
  116.             release: modHdl  148 die
  117.         THEN
  118.     THEN
  119.     moveHi: modHdl                        \ Move module hi since it gets locked
  120.     clear: exec_cnt  ;m
  121.  
  122.  
  123. :m RELEASE:  { \ svModbase -- }
  124.     clear: exec_cnt                    \ We certainly hope we know what we're
  125.     clear: locked?                    \  doing!!
  126.     get: modHdl  nilH =  ?EXIT        \ Out if not loaded
  127.     get: relOffs  -1 <>                \ Any module-specific action?
  128.     IF                                \ Yes
  129.         lock: modHdl                \ We're going to execute in the module
  130.         modbase -> svModbase
  131.         ptr: modHdl  32766 +  dup  -> modbase
  132.         get: relOffs +
  133.         execute                        \ Execute the appropriate word
  134.         svModbase -> modbase        \ No need to unlock since we're
  135.                                     \  just about to release
  136.     THEN
  137.     get: res#                          \ Resource?
  138.     IF
  139.         get: modHdl  trap$ a9a3        \ call ReleaseResource
  140.         nilH put: modHdl
  141.     ELSE
  142.         release: modHdl
  143.     THEN
  144.     true -> released?  ;m
  145.  
  146. (*
  147. KEEP: and DROP: flag this module as needed and not needed, respectively.
  148. The main purpose of this flagging is that if GETSPACE is called, loaded
  149. modules will be released to make room, unless they have been flagged as
  150. needed by KEEP:.  But note that RELEASE: ignores the flag, so that we
  151. can get rid of a module by force if necessary.  This may happen if there
  152. was a crash while the module was executing.
  153.  
  154. LOCK: is more drastic than KEEP:, since it means that this module becomes
  155. non-relocatable.  UNLOCK: reverses a LOCK:.  Note that DROP: in effect does
  156. an UNLOCK: as well.
  157.  
  158. This "locking" feature is used for ExtrasMod, which has a window, and
  159. for the debugger and printMod, which can be entered through the back
  160. door (via a vect or a trap).  (By the way, we hope we won't have to do this
  161. back door business anywhere else.  Entering a module through the back door
  162. is not usually a very safe thing to do.)
  163.  
  164. Locking a module can give a useful performance improvement if a module is to
  165. be called several times in succession, since we bypass the _HLock and _Hunlock
  166. calls if the module is marked locked.
  167. *)
  168.  
  169. :m KEEP:
  170.     addr: flags 1 bset  ;m
  171.  
  172. :m DROP:
  173.     get: exec_cnt NIF  unlock: modHdl  THEN  \ Unlock if not executing
  174.     addr: flags 1 breset  clear: locked?  ;m
  175.  
  176. :m LOCK:
  177.     true  put: locked?  load: self  lock: modHdl  ;m
  178.         \ Note: loading does a MoveHi so we don't need to do it again.
  179.  
  180. :m UNLOCK:
  181.     false  put: locked?
  182.     get: exec_cnt NIF  nil?: modHdl NIF  unlock: modHdl  THEN THEN  ;m
  183.  
  184. :m KEEP?:
  185.     get: exec_cnt  0<>  get: locked?  or  get: flags  or  ;m
  186.  
  187. :m LOCKED?:
  188.     get: exec_cnt  get: locked?  or  ;m
  189.  
  190.  
  191. :m ?RELEASE:
  192.     keep?: self  ?EXIT
  193.     release: self  ;m
  194.  
  195. :m #IMP:    get: #imp  ;m
  196.  
  197. :m GETIMPORTS:  { \ n -- }
  198.     0 -> n
  199.     BEGIN
  200.         header  -92 w,        \ Header with handler code for imported word
  201.         ^base compimp  1 ++> n
  202.         & }  endlist?
  203.     UNTIL
  204.     n 1-  put: #imp
  205.     latest  name>  put: lastimp
  206.     here  put: loadpoint  ;m
  207.  
  208.  
  209. \                ===================================
  210. \                        Module compilation
  211. \                ===================================
  212.  
  213. private
  214.  
  215. :m ExpSupers:  { ^nw -- }
  216.     BEGIN
  217.         ^nw @ 0EXIT
  218.         ^nw relocType  InThisMod =
  219.         IF  ^nw @abs mfa displace  expMethods: [self]  THEN
  220.         4 ++> ^nw
  221.     AGAIN  ;m
  222.  
  223. public
  224.                 \ This gets called via a late bind, so must be public
  225. :m ExpMethods:  { maddr -- }
  226.     BEGIN                \ Loop thru methods in this class
  227.         maddr @ 0>=
  228.         IF            \ We've come to the superclasses
  229.             maddr  expSupers: self  EXIT
  230.         THEN
  231.                     \ Next method
  232.         maddr 10 +  >nxtExp
  233.         maddr 4+ displace  -> maddr
  234.     AGAIN  ;m
  235.  
  236. private
  237.  
  238.  
  239. mlocal !exports: { \ thisImp thisCfa maddr -- }
  240.  
  241. :m ?!class:    \ If this exported item is a class, we set the handler
  242.             \ code of the imported version and add the method entry offsets
  243.             \ to the export table.
  244.  
  245.     thisCfa 2- w@x -58 =  0EXIT        \ Out if it isn't a class
  246.     -90  thisImp 2- w!
  247.     thisCfa ffa 1+ 1 bset
  248.     thisCfa mfa  displace  expMethods: self  ;m
  249.  
  250.  
  251. :m 1export:
  252.     next: theMark  link> -> thisImp
  253.     thisImp  >name n>count  sFind
  254.     drop -> thisCfa
  255.     thisCfa thisImp =
  256.     IF                                        \ Not defined
  257.         cr thisImp .id  2 spaces  144 die
  258.                                     \ "You forgot to define this exported name"
  259.         false -> cleanMod?
  260.     ELSE                            \ All OK. Put info into import definition:
  261.         thisCfa >name c@  thisImp >name c!    \ Name flags
  262.         pos: $exp  thisImp 4+ w!            \ Export table index
  263.         thisCfa >nxtExp                        \ Add next exp tbl entry
  264.         ?!class: self                        \ More stuff if it's a class
  265.     THEN  ;m
  266.  
  267.  
  268. :mloc !exports:        \ { \ n thisImp thisCfa maddr -- }
  269.     get: #imp  0= ?error 143            \ Module has no exported names
  270.     clear: $exp
  271.     get: lastimp  set: theMark
  272.     get: #imp  FOR  1export: self  NEXT
  273. ;mloc
  274.  
  275.  
  276. (*
  277. FixLinks: fixes up the dictionary links within the compiled module.  We may
  278. want to find words in the module at run time via FIND, but the problem is that
  279. dic links are relative, not relocatable.  This makes FIND fast, but leads
  280. to a problem at run time when the the module is disconnected from the main
  281. dictionary.  If we didn't do anything, we wouldn't know where to start
  282. searching from, and if the search failed, the last link would point into
  283. outer space.
  284. So what we do is to add a snapshot of CONTEXT to the end of the module to give
  285. a place to start from, and to clear the lowest link on each thread to zero (which
  286. means the end).
  287. *)
  288.  
  289. :m FixLinks:  { \ link prevLink -- }
  290.     #threads FOR
  291.         context  i cells +  -> link
  292.         BEGIN
  293.             link -> prevLink
  294.             link displace -> link
  295.             link modstart u<
  296.         UNTIL
  297.         0 prevLink !
  298.     NEXT
  299.     here 4+ context -  ,            \ Adjustment value for context copy
  300.     context 32  n,                    \ Add copy of Context to end of module
  301. ;m
  302.  
  303. :m GoodCompile:  { \ size -- }
  304.     here  modstart 8 +  displ!        \ Store export table offs in header
  305.     all: $exp  n,                    \ Add export table to end
  306.     fixLinks: self                    \ fix dic links in module
  307.     here modstart -  -> size        \ Size of module
  308.     size  modstart 12 +  !            \ Store size in header
  309.     binName: self  name: fFcb        \ Set name of binary file
  310.     create: fFcb  ?error 139
  311.     'type BIN  'type MOPS  set: fFcb    \ Type and signature
  312.     modstart  size  write: fFcb            \ Write out binary module
  313.     close: fFcb  drop
  314.     IF    msg# 140                    \ I/O error on writing bin file
  315.     ELSE
  316.         curs  -curs
  317.         cr  getName: fFcb type  ."  saved" cr
  318.         -> curs
  319.     THEN
  320. ;m
  321.  
  322. public
  323.  
  324. :m COMPILE:  { \ newModbase -- }
  325.     compMod  ?error 177                    \ Error if already compiling a module
  326.     release: self                        \ Get rid of old version, if loaded
  327.     context 32  put: $cxt                \ save CONTEXT since we're going
  328.                                         \ to do a temporary FORGET
  329.     DP -> svDP  latest -> svLatest  ^base -> compMod
  330.     get: loadpoint  (forget)  svDP -> DP
  331.     true -> cleanMod?
  332.     pushNew: loadFile
  333.     txtName: self  name: topFile
  334.     here -> modstart
  335.     modstart 32766 +  -> newModbase
  336.     16  reserve            \ Reserve space for header and offset to exports table.
  337.     ^base -> this_mod
  338.     newModbase LdFromMod
  339.     dateTime  modstart !                \ Put source date in bin module header
  340.     getDirID: topFile  modstart 4+ !    \ Also DirID of source file
  341.     drop: loadfile
  342.     0 -> this_mod
  343.     !exports: self
  344.     cleanMod?
  345.     IF    goodCompile: self            \ Everything's OK.  Do final housekeeping
  346.     THEN
  347.     unmod                            \ Also releases $cxt
  348.     release: $exp  ;m
  349.  
  350.  
  351. \ FIND: works like FIND, but just searches for a word in this module.
  352.  
  353. :m FIND: { s255 \ thrdOffs modCxt cxtOffs -- cfa T | -- s255 F }
  354.     load: self
  355.     s255                                    \ leave on stack for (find)
  356.     dup c@ 7 and 4*  -> thrdOffs            \ like what THREAD does
  357.     nptr: modHdl  size: modHdl +  32 -  -> modCxt
  358.     modCxt 4- @  -> cxtOffs
  359.     modCxt thrdOffs +  displace
  360.     dup NIF            \ thread is empty
  361.         drop false  EXIT
  362.     THEN
  363.     cxtOffs -
  364.     ( s255 1st-link )  (find)
  365. ;m
  366.  
  367. :m CLASSINIT:
  368.     -1  put: relOffs
  369.     dateTime put: dicDateTime  ;m
  370.  
  371. ;class
  372.  
  373.  
  374. : SETRELEASE    \ ( addr -- )
  375.     setRelease: [ this_mod ]  ;
  376.  
  377. : MLD
  378.     dup  load: **  ;
  379.  
  380. ' mld -> modLoad
  381.  
  382. : MOD?        \ ( cfa -- cfa b )
  383.     objCfa?  NIF  false  EXIT  THEN
  384.     dup >obj >classCfa  ['] module  =  ;
  385.  
  386.  
  387. : ?DISP  { theCfa size -- }        \ handler to release selected modules
  388.     theCfa mod?  NIF  drop  EXIT  THEN
  389.     free size <            \ Do we still need space?
  390.     IF    >obj  ?release: module
  391.     ELSE    drop
  392.     THEN  ;
  393.  
  394.  
  395. \ PURGE forcibly releases all modules, no matter what.  It is a vector,
  396. \ defined in file Base.
  397.  
  398. : (PRG)  { theCfa size -- }    \ unlock and release
  399.     theCfa mod? NIF  drop  EXIT  THEN
  400.     >obj release: module  ;
  401.  
  402. : (PURGE)    ['] (prg)  big#  trav  ;
  403.  
  404. ' (purge) -> purge
  405.  
  406.  
  407. : NEEDSPACE    \ ( #bytes -- ) release modules until #bytes are available
  408.     false -> released?
  409.     freeblk drop  ['] ?disp swap trav  ;
  410.  
  411. : GS    big# needSpace  released?  ;
  412.  
  413. ' gs -> getSpace
  414.  
  415.  
  416. : FROM        \ ( -- ^mod sec# )
  417.     module                            \ Create module object
  418.     latest name> >obj  dup -> last_mod  28  ;
  419.  
  420.  
  421. : IMPORT{    \ ( ^mod sec# -- )
  422.     28 ?pairs  getImports: **  ;
  423.  
  424. : EXPORTS_CLASS
  425.     last_mod  exports_class: **  ;
  426.  
  427.  
  428.  
  429. (* EVAL" ... " performs an EVALUATE on the quoted string, with one important
  430.    difference to EVALUATE - it temporarily returns the dictionary to the
  431.    state it was in when the EVAL" was compiled.  This ensures that any
  432.    later redefinitions of words in the quoted string won't be used.  This
  433.    is usually what you want.  If you want redefinitions to be used, use
  434.    EVALUATE.
  435.    Note - we've put this definition here in the Modules file, since the
  436.    saving and restoring of the dictionary state is almost identical
  437.    to what has to be done during module compilation.
  438. *)
  439.  
  440. : (EVAL")
  441.     context 32  put: $evCxt        \ save CONTEXT since we're going
  442.                                 \ to do a temporary FORGET
  443.     DP -> evSvDP  latest -> evSvLatest
  444.     fence  0 -> fence            \ disable fence check on (forget) since
  445.                                 \  we might be in a module located below
  446.                                 \  the dic in memory!
  447.     r>                            \ caller addr is where we forget to
  448.     dup  (forget)
  449.     swap  -> fence                \ restore fence
  450.     evSvDP -> DP                \ restore DP (but context is still forgotten)
  451.     count
  452.     2dup + aligned  >r
  453.     unEval                        \ restore context etc.
  454.     evaluate  ;
  455.  
  456. : EVAL"
  457.     postpone (eval")
  458.     ,"                \ parse string delimited by " , add to dic
  459. ;                        immediate
  460.  
  461.  
  462. (* ******
  463. \ Testing:
  464.  
  465. : QQ    ." The right QQ!" cr  ;
  466.  
  467. from TESTMOD  import{ AA BB CC }
  468.  
  469. : QQ    ." This is the wrong QQ!!!"  ;        \ This one shouldn't!
  470.  
  471. compile: testmod
  472.  
  473. : LOOKFOR    Mword  find: testmod  ;
  474.  
  475. ****** *)
  476.  
  477.  
  478. \ Now that's done, the next thing we need to do is set up our HFS file
  479. \ access:
  480.  
  481. from PATHSMOD    import{  OWP  GETPATHS  .PATHS  }
  482.  
  483. :f OPEN_WITH_PATHS    OWP  ;f
  484.  
  485. compile: pathsMod
  486.  
  487. true -> use_paths?
  488. " mops.paths"  getPaths
  489.  
  490. \ Right, we now have HFS paths, so we can access our source files in
  491. \ different folders.
  492.  
  493. from CALL1&LMOD    import{  CallFirst  CallLast  (GET)  (C1)  (CL)  }
  494.  
  495. ' (get) -> get1st&last
  496. ' (C1)  -> doCall1st
  497. ' (CL)  -> doCallLast
  498.  
  499. compile: call1&Lmod
  500.  
  501.  
  502.  
  503. 0    value        CASE_TYPE
  504.  
  505. from CASEMOD     import{  case[ ]=> ], range]=> range], default=> ]case
  506.                             select[  ]select }
  507.  
  508. compile: caseMod
  509.  
  510. : SELECT{    postpone select[  ;        immediate
  511. : }SELECT    postpone ]select  ;        immediate
  512. : IS{        postpone ]=>      ;        immediate
  513. : }END        postpone [          ;        immediate
  514. : DEFAULT{    postpone ]  postpone default=>  postpone drop  ;    immediate
  515.  
  516.  
  517. \ from TOOL        import{  CALL ASMCALL FCALL GLOBAL $>GLOB KONST $>KONST  }
  518.  
  519. from TOOL        import{  CALL ASMCALL FCALL GLOBAL $>GLOB  }
  520. compile: tool
  521.  
  522. from CALLSMOD  import{  SYSCALL KONST $>KONST  }
  523. compile: callsMod
  524.  
  525. from ASMMOD    import{  ASM :CODE :MCODE TOCODE  }
  526. compile: asmmod
  527.  
  528. endload
  529.  
  530.  
  531.  
  532.  
  533. \ More testing stuff:
  534.  
  535. +echo
  536.  
  537. :class    HAHA    super{ int }
  538.  
  539. callLast    print:
  540.  
  541. :m BAtest:
  542.     1 2 3 . . .  ;m
  543. ;class
  544.  
  545. :class SUBHAHA  super{ haha }
  546.  
  547. callLast    dump:
  548.  
  549. :m BAtest:  -9 -8 -7 . . .  ;m
  550.  
  551. ;class
  552.  
  553. haha    hh
  554. subhaha    ss
  555.  
  556. : q db batest: hh  batest: ss  ;
  557.  
  558. endload
  559.  
  560.  
  561. : QQ    ." QQ here.  Hello. "  ;        \ This gets called from testMod
  562.  
  563. variable VB
  564.  
  565. \ compile: testmod2
  566.